Hardcore Visual Basic 5.0 (2nd Edition)/Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso/Code/LOCALM~1/FileTool.bas

BASIC Source File | 1997-06-14 | 15.2 KB | 419 lines

Attribute VB_Name = "MFileTool"
Option Explicit

Public Enum EErrorFileTool
    eeBaseFileTool = 13480      ' FileTool
End Enum

Public Enum EWalkModeFile
    ewmfDirs = &H20
    ewmfFiles = &H40
    ewmfBoth = &H20 Or &H40
End Enum

Private Declare Function SHFileOperation Lib "shell32.dll" _
    Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Type SHFILEOPSTRUCT
    hWnd As Long                ' Window owner of any dialogs
    wFunc As Long               ' Copy, move, rename, or delete code
    pFrom As String             ' Source file
    pTo As String               ' Destination file or directory
    fFlags As Integer           ' Options to control the operations
    fAnyOperationsAbortedLo As Integer ' Indicates partial failure
    fAnyOperationsAbortedHi As Integer
    hNameMappingsLo As Long     ' Array indicating each success
    hNameMappingsHi As Long
    lpszProgressTitleLo As Long ' Title for progress dialog
    lpszProgressTitleHi As Long
End Type

Const datMin As Date = #1/1/100#
Const datMax  As Date = #12/31/9999 11:59:59 PM#

' Difference between day zero for VB dates and Win32 dates
' (or #12-30-1899# - #01-01-1601#)
Const rDayZeroBias As Double = 109205#   ' Abs(CDbl(#01-01-1601#))

' 10000000 nanoseconds * 60 seconds * 60 minutes * 24 hours / 10000
' comes to 86400000 (the 10000 adjusts for fixed point in Currency)
Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Function Win32ToVbTime(ft As Currency) As Date
    Dim ftl As Currency
    ' Call API to convert from UTC time to local time
    If FileTimeToLocalFileTime(ft, ftl) Then
        ' Local time is nanoseconds since 01-01-1601
        ' In Currency that comes out as milliseconds
        ' Divide by milliseconds per day to get days since 1601
        ' Subtract days from 1601 to 1899 to get VB Date equivalent
        Win32ToVbTime = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)
    Else
        ApiRaise Err.LastDllError
    End If
End Function

Function VbToWin32Time(dat As Date) As Currency
    Dim ftl As Currency
    ' Date is days since 1899
    ' Add days from 1601 to 1899 to get Win32 days
    ' Multiply by milliseconds per day to get milliseconds since 1601
    ' That would be nanoseconds if it weren't in Currency
    ftl = CCur((CDbl(dat) + rDayZeroBias) * rMillisecondPerDay)
    ' Call API to convert from local time to UTC time
    If LocalFileTimeToFileTime(ftl, VbToWin32Time) = 0 Then
        ApiRaise Err.LastDllError
    End If
End Function

Function FileAnyDateTime(sPath As String, _
                         Optional datCreation As Date = datMin, _
                         Optional datAccess As Date = datMin) As Date
    ' Take the easy way if no optional arguments
    If datCreation = datMin And datAccess = datMin Then
        FileAnyDateTime = VBA.FileDateTime(sPath)
        Exit Function
    End If

    Dim fnd As WIN32_FIND_DATA
    Dim ftCreate As FILETIME, ftAccess As FILETIME, ftModify As FILETIME
    Dim hFind As Long, f As Boolean, stime As SYSTEMTIME
    ' Get all three times in UDT
    hFind = FindFirstFile(sPath, fnd)
    If hFind = hInvalid Then ApiRaise Err.LastDllError
    FindClose hFind
    ' Convert them to Visual Basic format
    datCreation = Win32ToVbTime(fnd.ftCreationTime)
    datAccess = Win32ToVbTime(fnd.ftLastAccessTime)
    FileAnyDateTime = Win32ToVbTime(fnd.ftLastWriteTime)
End Function

Sub ReplaceFile(sOld As String, sTmp As String)
    Dim fnd As WIN32_FIND_DATA, hFind As Long, hOld As Long, f As Boolean
    ' Get file time and attributes of old file
    hFind = FindFirstFile(sOld, fnd)
    If hFind = hInvalid Then ApiRaise Err.LastDllError
    ' Replace by deleting old and renaming new to old
    Kill sOld
    Name sTmp As sOld
    ' Assign old attributes and time to new file
    hOld = lopen(sOld, OF_WRITE Or OF_SHARE_DENY_WRITE)
    If hOld = hInvalid Then ApiRaise Err.LastDllError
    f = SetFileTime(hOld, fnd.ftCreationTime, _
                    fnd.ftLastAccessTime, fnd.ftLastWriteTime)
    If f Then ApiRaise Err.LastDllError
    lclose hOld
    f = SetFileAttributes(sOld, fnd.dwFileAttributes)
    If f Then ApiRaise Err.LastDllError
End Sub

' Better version of FileCopy (CopyAnyFile) and matching MoveAnyFile,
' DeleteAnyFile, and RenameAnyFile

Function CopyAnyFile(sSrc As String, sDst As String, _
                     Optional Options As Long = 0, _
                     Optional Owner As Long = hNull) As Boolean
    If MUtility.HasShell Then
        Dim fo As SHFILEOPSTRUCT, f As Long
        fo.wFunc = FO_COPY
        Debug.Print TypeName(fo.wFunc)
        fo.pFrom = sSrc
        fo.pTo = sDst
        fo.fFlags = Options
        fo.hWnd = Owner
        ' Mask out invalid flags
        fo.fFlags = fo.fFlags And FOF_COPYFLAGS
        f = SHFileOperation(fo)
        CopyAnyFile = (f = 0)
    Else
        ' For Windows NT 3.51
        On Error Resume Next
        ' FileCopy expects full name of destination file
        FileCopy sSrc, sDst
        If Err Then
            Err = 0
            ' CopyAnyFile can handle destination directory
            sDst = MUtility.NormalizePath(sDst) & _
                   MUtility.GetFileBaseExt(sSrc)
            FileCopy sSrc, sDst
        End If
        ' Enhance further to emulate SHFileOperation options
        ' such as validation and wild cards
        CopyAnyFile = (Err = 0)
    End If
End Function

Function MoveAnyFile(sSrc As String, sDst As String, _
                  Optional afOptions As Long = 0, _
                  Optional Owner As Long = hNull) As Boolean
    If MUtility.HasShell Then
        Dim fo As SHFILEOPSTRUCT, f As Long
        fo.wFunc = FO_MOVE
        fo.pFrom = sSrc
        fo.pTo = sDst
        fo.fFlags = afOptions
        fo.hWnd = Owner
        ' Mask out invalid flags
        fo.fFlags = fo.fFlags And FOF_COPYFLAGS
        f = SHFileOperation(fo)
        MoveAnyFile = (f = 0)
    Else
        ' Windows NT 3.51
        On Error Resume Next
        ' Name actually moves
        Name sSrc As sDst
        If Err Then ' Probably you gave directory destination
            Err = 0
            sDst = MUtility.NormalizePath(sDst) & _
                   MUtility.GetFileBaseExt(sSrc)
            Name sSrc As sDst
        End If
        ' Enhance further to emulate SHFileOperation options
        ' such as validation and wild cards
        MoveAnyFile = (Err = 0)
    End If
End Function

Function RenameAnyFile(sSrc As String, sDst As String, _
                       Optional Options As Long = 0, _
                       Optional Owner As Long = hNull) As Boolean
    If MUtility.HasShell Then
        Dim fo As SHFILEOPSTRUCT, f As Long
        fo.wFunc = FO_RENAME
        'fo.pFrom = StrPtr(sSrc)
        'fo.pTo = StrPtr(sDst)
        fo.pFrom = sSrc
        fo.pTo = sDst
        fo.fFlags = Options
        fo.hWnd = Owner
        ' Mask out invalid flags
        fo.fFlags = fo.fFlags And FOF_RENAMEFLAGS
        f = SHFileOperation(fo)
        RenameAnyFile = (f = 0)
    Else
        ' Windows NT 3.51
        On Error Resume Next
        Name sSrc As sDst
        RenameAnyFile = (Err = 0)
        ' Enhance further to emulate SHFileOperation options
        ' such as validation and wild cards
    End If
End Function

Function DeleteAnyFile(sSrc As String, _
                    Optional Options As Long = 0, _
                    Optional Owner As Long = hNull) As Boolean
    If MUtility.HasShell Then
        Dim fo As SHFILEOPSTRUCT, f As Long
        fo.wFunc = FO_DELETE
        fo.pFrom = sSrc
        ' fo.pTo = sNullStr
        fo.fFlags = Options
        fo.hWnd = Owner
        ' Mask out invalid flags
        fo.fFlags = fo.fFlags And FOF_DELETEFLAGS
        f = SHFileOperation(fo)
        DeleteAnyFile = (f = 0)
    Else
        ' Windows NT 3.51
        On Error Resume Next
        Kill sSrc
        DeleteAnyFile = (Err = 0)
        ' Enhance further to emulate SHFileOperation options
        ' such as validation and wild cards
    End If
End Function

Function Files(hFiles As Long, fi As CFileInfo, _
               ByVal sSpec As String, _
               Optional afAttr As Long = 0) As String
    Dim fd As WIN32_FIND_DATA, sName As String, f As Boolean, sPath As String

    ' Stop finding and close handle early
    If afAttr = -1 Then
        f = FindClose(hFiles)
        hFiles = 0: Exit Function
    End If
    f = True
    Do
        ' Get first or next file
        If hFiles = 0 Then
            hFiles = FindFirstFile(sSpec, fd)
        Else
            f = FindNextFile(hFiles, fd)
        End If
        If (f = False Or hFiles = INVALID_HANDLE_VALUE) Then
            If Err.LastDllError = ERROR_NO_MORE_FILES Then
                f = FindClose(hFiles)
            End If
            hFiles = 0: Exit Function
        End If
        ' Keep looping until something matches attributes
    Loop While (afAttr <> vbNormal) And _
               ((afAttr And fd.dwFileAttributes) = 0)
    ' Get file data and return through reference
    sPath = MUtility.GetFileDir(sSpec)
    sName = MUtility.StrZToStr(MBytes.BytesToStr(fd.cFileName))
    fi.CreateFromFile sPath & sName, fd.dwFileAttributes, _
                      fd.nFileSizeLow, fd.ftLastWriteTime, _
                      fd.ftLastAccessTime, fd.ftCreationTime
    Files = sName
End Function


' Efficient find files function
Function FindFiles(sTarget As String, _
                   Optional ByVal Start As String) As Collection

    ' Statics for less memory use in recursive procedure
    Static sName As String, sSpec As String, nFound As New Collection
    Static fd As WIN32_FIND_DATA, iLevel As Long
    Dim hFiles As Long, f As Boolean
    If Start = sEmpty Then Start = CurDir$
    ' Maintain level to ensure collection is cleared first time
    If iLevel = 0 Then
        Set nFound = Nothing
        Start = MUtility.NormalizePath(Start)
    End If
    iLevel = iLevel + 1

    ' Find first file (get handle to find)
    hFiles = FindFirstFile(Start & "*.*", fd)
    f = (hFiles <> INVALID_HANDLE_VALUE)
    Do While f
        sName = MBytes.ByteZToStr(fd.cFileName)
        ' Skip . and ..
        If Left$(sName, 1) <> "." Then
            sSpec = Start & sName
            If fd.dwFileAttributes And vbDirectory Then
                DoEvents
                ' Call recursively on each directory
                FindFiles sTarget, sSpec & "\"
            ElseIf StrComp(sName, sTarget, 1) = 0 Then ' Text comparison
                ' Store found files in collection
                nFound.Add sSpec
            End If
        End If
        ' Keep looping until no more files
        f = FindNextFile(hFiles, fd)
    Loop
    f = FindClose(hFiles)
    ' Return the matching files in collection
    Set FindFiles = nFound
    iLevel = iLevel - 1
End Function

Function WalkAllFiles(fileit As IUseFile, _
                      Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
                      Optional ByVal Start As String) As Boolean

    ' Statics for less memory use in recursive procedure
    Static sName As String, fd As WIN32_FIND_DATA, iLevel As Long
    Static fi As New CFileInfo
    Dim hFiles As Long, f As Boolean
    If Start = sEmpty Then Start = CurDir$
    ' Maintain level to ensure collection is cleared first time
    If iLevel = 0 Then Start = MUtility.NormalizePath(Start)
    iLevel = iLevel + 1

    ' Find first file (get handle to find)
    hFiles = FindFirstFile(Start & "*.*", fd)
    f = (hFiles <> INVALID_HANDLE_VALUE)
    Do While f
        sName = MBytes.ByteZToStr(fd.cFileName)
        ' Skip . and ..
        If Left$(sName, 1) <> "." Then
            ' Create a file info object from file data
            fi.CreateFromFile Start & sName, fd.dwFileAttributes, _
                              fd.nFileSizeLow, fd.ftLastWriteTime, _
                              fd.ftLastAccessTime, fd.ftCreationTime
            If fd.dwFileAttributes And vbDirectory Then
                If ewmf And ewmfDirs Then
                    ' Let client use directory data
                    WalkAllFiles = fileit.UseFile(iLevel, Start, fi)
                    ' If client returns True, walk terminates
                    If WalkAllFiles Then Exit Function
                End If
                ' Call recursively on each directory
                WalkAllFiles = WalkAllFiles(fileit, ewmf, _
                                            Start & sName & "\")
            Else
                If ewmf And ewmfFiles Then
                    ' Let client use file data
                    WalkAllFiles = fileit.UseFile(iLevel, Start, fi)
                    ' If client returns True, walk terminates
                    If WalkAllFiles Then Exit Function
                End If
            End If
        End If
        ' Keep looping until no more files
        f = FindNextFile(hFiles, fd)
    Loop
    f = FindClose(hFiles)
    ' Return the matching files in collection
    iLevel = iLevel - 1
End Function

Function WalkFiles(fileit As IUseFile, _
                   Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
                   Optional ByVal Start As String, _
                   Optional UserData As Variant) As Boolean

    Dim sName As String, sSpec As String, fd As WIN32_FIND_DATA
    Dim hFiles As Long, f As Boolean, fi As New CFileInfo
    If Start = sEmpty Then Start = CurDir$
    Start = MUtility.NormalizePath(Start)

    ' Find first file (get handle to find)
    hFiles = FindFirstFile(Start & "*.*", fd)
    f = (hFiles <> INVALID_HANDLE_VALUE)
    Do While f
        sName = MBytes.ByteZToStr(fd.cFileName)
        ' Skip . and ..
        If Left$(sName, 1) <> "." Then
            ' Create a file info object from file data
            fi.CreateFromFile Start & sName, fd.dwFileAttributes, _
                              fd.nFileSizeLow, fd.ftLastWriteTime, _
                              fd.ftLastAccessTime, fd.ftCreationTime
            If fd.dwFileAttributes And vbDirectory Then
                If ewmf And ewmfDirs Then
                    ' Let client use directory data
                    WalkFiles = fileit.UseFile(UserData, Start, fi)
                End If
            Else
                If ewmf And ewmfFiles Then
                    ' Let client use file data
                    WalkFiles = fileit.UseFile(UserData, Start, fi)
                End If
            End If
            ' If client returns True, walk terminates
            If WalkFiles Then Exit Function
        End If
        ' Keep looping until no more files
        f = FindNextFile(hFiles, fd)
    Loop
    f = FindClose(hFiles)
End Function
'

#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
    Dim sText As String, sSource As String
    If e > 1000 Then
        sSource = App.ExeName & ".FileTool"
        Select Case e
        Case eeBaseFileTool
            BugAssert True
       ' Case ee...
       '     Add additional errors
        End Select
        Err.Raise COMError(e), sSource, sText
    Else
        ' Raise standard Visual Basic error
        sSource = App.ExeName & ".VBError"
        Err.Raise e, sSource
    End If
End Sub
#End If